home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / metamail / contrib / ServiceMail / src / mesh / init.tcl < prev    next >
Encoding:
Text File  |  1993-03-18  |  4.1 KB  |  149 lines
  1. # These proc definitions are preloaded by the MESH program
  2.  
  3. # 1-21-93 weber@eitech.com added define-pattern and support in
  4. #  invoke-service for pattern matching
  5.  
  6.  
  7. # the next three procs implement "assoc" lists for tcl; these are very
  8. # handy for examining service inputs and composing service outputs.
  9. # Yes, I know about the keylists in extended tcl, but I didn't like them
  10. #
  11. proc delfield {structname field} {
  12.   if {[catch "upvar $structname struct"]} {return}
  13.   set i [expr [llength $struct]-1]
  14.   while {$i>1} {
  15.     incr i -2
  16.     if {[lindex $struct $i] == $field} {
  17.       set struct [lreplace $struct $i [expr $i+1]]
  18.     }
  19.   }
  20. }
  21.  
  22. proc setfield {structname field value} {
  23.   upvar $structname struct
  24.   lappend struct $field $value
  25. }
  26.  
  27. proc getfield {struct field} {
  28.   set i [llength $struct]
  29.   while {$i>1} {
  30.     incr i -2
  31.     if {[lindex $struct $i] == $field} {
  32.       return [lindex $struct [expr $i+1]]
  33.     }
  34.   }
  35.   return {}
  36. }
  37.  
  38. # The following proc is used by the services.tcl file to define
  39. # available services
  40. proc define-service {extname intname sfile} {
  41.   global executor srcfile
  42.   set executor($extname) $intname
  43.   set srcfile($extname) $sfile
  44. }
  45.  
  46. proc define-pattern {extname pattern} {
  47.   global pats
  48.   lappend pats [list $extname $pattern]
  49. }
  50.  
  51. # This is the Tcl proc that called by the mesh code to invoke a service.
  52. # It handles error conditions like no-such-service, an incorrect
  53. # installation of implementations, or errors during service execution
  54. #
  55. proc invoke-service {extname switches envelope inputs} {
  56.   global executor hmph servlog administrator errorInfo pats srcfile
  57.  
  58. # if a log file is defined, log this request
  59. #
  60.   if {[info exists servlog] && [catch {set fid [open $servlog a]}] == 0} {
  61.     puts $fid $extname
  62.     puts $fid $switches
  63.     puts $fid $envelope
  64.     puts $fid $inputs
  65.     puts $fid ""
  66.     close $fid
  67.   }
  68.  
  69. # check for matching patterns first
  70. #
  71.   if {[info exists pats]} {
  72.     foreach pat $pats {
  73.       if [lindex $pat 1] {
  74.         set extname [lindex $pat 0]
  75.         break
  76.       }
  77.     }
  78.   }
  79. # now try to execute service
  80. #
  81.   if {![info exists executor($extname)]} {
  82.     set servlist [array names executor]
  83.         regsub -all " " $servlist "\n" servlist
  84.     setfield response STRING \
  85. "Sorry, this server does not have a $extname service.
  86.  
  87. Services are normally invoked by specifying their name as the first
  88. word in the subject line, followed by any necessary arguments.
  89.  
  90. Currently available services:
  91.  
  92. $servlist"
  93.     return [mailout [turnaround $envelope] $response]
  94.   }
  95.   if {[catch "uplevel #0 {source $srcfile($extname)}" errstr] ||
  96.       [catch "$executor($extname) [list $switches] [list $envelope] [list $inputs]" errstr]} {
  97.     if {[info exists administrator]} {
  98.       setfield response STRING \
  99. "The '$extname' service encountered an error on the following request:
  100.  
  101. $envelope
  102.  
  103. Here is a stacktrace of the problem:
  104.  
  105. $errorInfo"
  106.       setfield outenv TO $administrator
  107.       setfield outenv SUBJECT "A ServiceMail bug"
  108.       mailout $outenv $response
  109.       setfield response STRING \
  110. "Sorry, the '$extname' service encountered a problem.
  111. A bug report has been automatically sent to our ServiceMail
  112. administrator."
  113.     } {
  114.       setfield response STRING \
  115. "Sorry, the '$extname' service encountered a problem.  Please contact
  116. our ServiceMail administrator and report the error with the following
  117. stacktrace:
  118. $errorInfo"
  119.     }
  120.     set outenv [turnaround $envelope]
  121.     return [mailout $outenv $response]
  122.   }
  123. }
  124.  
  125. # This proc is used to construct outgoing envelopes from incoming
  126. # envelopes
  127. proc turnaround {inenvelope} {
  128.   set i 0
  129.   set outenvelope {}
  130.   while {[set f [lindex $inenvelope $i]] != ""} {
  131.     incr i
  132.     case $f {
  133.       REPLYTO { setfield outenvelope TO [lindex $inenvelope $i] }
  134.       MESSAGEID { setfield outenvelope INREPLYTO [lindex $inenvelope $i] }
  135.       SERVICE { setfield outenvelope SUBJECT "Re: [lindex $inenvelope $i]" }
  136.       CC { setfield outenvelope CC [lindex $inenvelope $i] }
  137.       SPLITSIZE { setfield outenvelope SPLITSIZE [lindex $inenvelope $i] }
  138.     }
  139.     incr i
  140.   }
  141.   return $outenvelope
  142. }
  143.  
  144. # This proc implements a crude form of security by checking the FROM
  145. # address to see if its local
  146. proc local from {
  147.   return [regexp {^[^%@!]*$} $from]
  148. }
  149.